;; This file is part of scheme-GNUnet.
;; Copyright (C) 2021 Maxime Devos
;;
;; scheme-GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; scheme-GNUnet is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;; SPDX-License-Identifier: AGPL3.0-or-later

;; @author Maxime Devos (scheme-GNUnet)
;;
;; @brief General-purpose message queue (message handlers)
(library (gnu gnunet mq handler)
  (export <message-handler>
	  make-message-handler message-handler?
	  message-handler-index
	  verify-message? handle-message!
	  message-handlers message-handler-for)
  (import (rnrs records syntactic)
	  (rnrs base)
	  (only (srfi srfi-43)
		vector-index)
	  (only (gnu extractor enum)
		integer->value value->index)
	  (only (gnu gnunet message protocols)
		message-type message-type?))
  (begin
    ;; TODO support docstrings for record types
    ;; in Guile
    (define-record-type
	(<message-handler> make-message-handler message-handler?)
      ;; Message type to handle.  Currently a raw integer.
      (fields (immutable index message-handler-index)
	      ;; (() -> X) -> X for all X
	      (immutable interposition %message-handler-interposition)
	      (immutable verifier %message-verifier)
	      (immutable handler %message-handler))
      (protocol
       (lambda (%make)
	 (lambda (index interposition verifier handler)
	   "Make a message handler for messages of type
@var{index}.  @var{index} must be a @code{message-type},
or its raw numeric value."
	   (%make (canonicalise-index index)
		  interposition verifier handler))))
      (opaque #t)
      ;; Sure, why not?
      ;; Can be removed later (along with <message-handler>),
      ;; if proved troublesome.
      (sealed #f))

    (define (canonicalise-index index)
      (cond ((and (integer? index)
		  (exact? index)
		  (<= 0 index)
		  (< index 65536))
	     index)
	    ((message-type? index)
	     (value->index index))
	    ;; FIXME nicer error message
	    (#t (assert #f))))

    (define (call-with-interposed-environment handler thunk)
      "Call the thunk @var{thunk} in the dynamic environment
of the message handler @var{handler} -- e.g., temporarily
raise/lower the ambient authority (root filesystem, user & groups,
 ...) when running on the Hurd, or adjust logging ports."
      ((%message-handler-interposition handler) thunk))

    (define (verify-message? handler message)
      "Verify whether @var{handler} considers @var{message}
to be acceptable (true/false).  The message type should probably
be checked first, using @code{message-handler-index}."
      (call-with-interposed-environment
       handler
       (lambda () ((%message-verifier handler) message))))

    ;; Why #\!? Because in practice handlers need some state.
    (define (handle-message! handler message)
      "Call ‘handler’ procedure of @var{handler} with @var{message}
(in the interposed environment)."
      (call-with-interposed-environment
       handler
       (lambda () ((%message-handler handler) message))))

    (define (message-handlers . rest)
      "Construct a message handler vector, consisting
of the message handlers @var{rest}.  Currently, this
is just a vector, but that might change at some point
in the future!"
      ;; XXX check for duplicates
      (let ((vec (list->vector rest)))
	(vector-for-each (lambda (x) (assert (message-handler? x)))
			 vec)
	vec))

    ;; FIXME maybe a &no-handler exception is nicer?
    (define (message-handler-for handlers index)
      "Return the message handler for messages at an index
@var{index} (numeric value, or enum value), for the message
@var{message} (in the interposed environment).  If no suitable
handler is found, return @code{#f} instead."
      (let* ((index (canonicalise-index index))
	     (handler-index
	      (vector-index (lambda (handler)
			      (= index (message-handler-index handler)))
			    handlers)))
	(vector-ref handlers handler-index)))))
